perm filename FORMAT[MAC,LSP]2 blob
sn#519514 filedate 1980-06-25 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 Function for printing or creating nicely formatted strings. -*-LISP-*-
C00033 ENDMK
Cā;
; Function for printing or creating nicely formatted strings. -*-LISP-*-
; FORMAT prints several arguments according to a control argument.
; The control argument is either a string or a list of strings and lists.
; The strings and lists are interpreted consecutively.
; Strings are for the most part just printed, except that the character ~
; starts an escape sequence which directs other actions.
; A ~ escape sequence has an (optional) numeric parameter followed by a
; mode character.
; These escape actions can use up one or more of the non-control arguments.
; A list in the control-argument list is also interpreted as an escape.
; Its first element is the mode, a symbol which may be any length,
; and its remaining elements are parameters. The list (D 5) is equivalent
; to the ~ escape "~5D"; similarly, each ~ escape has an equivalent list.
; However, there are list escapes which have no ~ equivalent.
; Any undefined list escape is simply evaluated.
;These are the escape modes which are defined:
; ~nD Takes any number and prints as a decimal integer. If no arg,
; print without leading spaces. If arg and it fits in, put in leading
; spaces; if it doesnt fit just print it. If second arg, use that
; (or first char of STRING of it if not a number) instead of space
; as a pad char.
; ~nF Floating point
; ~nE Exponential notation
; ~nO Like D but octal
; ~nA Character string. If there is an n then pad the string with spaces
; on the right to make it n long. If it doesn't fit, ignore n.
; ~n,m,minpad,padcharA Pad on the right to occupy at least
; n columns, or if longer than that to begin with, pad to occupy
; n+p*m columns for some nonnegative integer p.
; at least minpad pad characters are produced in any case
; (default if not supplied = 0).
; padchar is used for padding purposes (default if not supplied = space).
; if padchar is not a number, the first character in STRING of it is used.
; A mode can actually be used to PRINC anything, not just a string.
; ~S Prin1 an object. Just like ~A (including parameters) but uses PRIN1.
; ~C One character, in any acceptable form.
; Control and meta bits print as alpha, beta, epsilon.
; ~n* Ignore the next n args. n defaults to 1.
; ~n% Insert n newlines. n defaults to 1.
; ~n| Insert n formfeeds. n defaults to 1.
; ~nX Insert n spaces. n defaults to 1.
; ~n~ Insert n tildes. n defaults to 1.
; ~& Perform the :FRESH-LINE operation on the stream.
; ~n,mT Tab to column n+pm, for p an integer >= 0.
; ~Q Apply the next arg to no arguments.
; (Q ...) Apply the next arg to the (unevaluated) parameters following the Q.
; ~P Insert an "s", unless its argument is a 1
; ~nG Goto the nth argument (zero based). The next command will get that
; argument, etc.
; ~E and ~F are not implemented. ~T is not implemented.
; (FORMAT <stream> <control arg> <args>)
; If <stream> is NIL, cons up and return a symbol.
; If <stream> is T, use STANDARD-OUTPUT (saves typing).
(DECLARE (SPECIAL |Tilde-ascii-value/||)
(*LEXPR FORMAT/:FERROR))
(SETQ |Tilde-ascii-value/|| (COND ((STATUS FEATURE SAIL) 26.)
((GETCHARN '|~| 1))))
;;; Kludges to make MacLISP like some of the LISPM functions
(DECLARE (*LEXPR FERROR FORMAT-CTL-JUSTIFY ENGLISH-PRINT /|-->)
(SPECIAL STANDARD-OUTPUT ROMAN-OLD **STREAM**))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () ))
(DEFMACRO NSUBSTRING (&REST W) `(FORMAT/:NSUBSTRING ,.w))
(DEFMACRO FERROR (&REST W) `(FORMAT/:FERROR ,.w))
(DEFMACRO STRING-SEARCH-CHAR (&REST W) `(FORMAT/:STRING-SEARCH-CHAR ,.w))
(DEFMACRO AR-1 (AR IND) `(ARRAYCALL T ,ar ,ind))
(DEFMACRO AS-1 (VAL AR IND) `(STORE (ARRAYCALL T ,ar ,ind) ,val))
(DEFMACRO >= (X Y) `(NOT (< ,x ,y)))
(DEFMACRO <= (X Y) `(NOT (> ,x ,y)))
(DEFMACRO NEQ (X Y) `(NOT (= ,x ,y)))
(DECLARE (SETQ DEFMACRO-FOR-COMPILING 'T DEFMACRO-DISPALCE-CALL 'T))
(DECLARE
(SPECIAL CTL-STRING ;The control string.
CTL-LENGTH ;STRING-LENGTH of CTL-STRING.
CTL-INDEX ;Our current index into the control string.
; Used by the conditional command. (NYI)
ATSIGN-FLAG ;Modifier
COLON-FLAG ;Modifier
FORMAT-TEMPORARY-AREA ;For temporary consing
FORMAT-ARGLIST ;The original arg list, for ~G.
))
(DEFUN FORMAT NARGS
(PROG (STREAM CTL-STRING ARGS FORMAT-STRING STANDARD-OUTPUT)
(OR (>= NARGS 2) (FERROR NIL '|Not enough args to FORMAT|))
(SETQ STREAM (COND ((EQ (ARG 1) 'T) () )
((NULL (ARG 1))
(SETQ FORMAT-STRING 'T)
(LIST **STREAM**))
((ARG 1)))
CTL-STRING (ARG 2)
ARGS (CDDR (LISTIFY NARGS)))
(SETQ STANDARD-OUTPUT STREAM) ;???
(SETQ FORMAT-ARGLIST ARGS)
(COND ((SYMBOLP CTL-STRING)
(FORMAT-CTL-STRING ARGS CTL-STRING))
(T (DO ((CTL-STRING CTL-STRING (CDR CTL-STRING)))
((NULL CTL-STRING))
(SETQ ARGS
(COND
((SYMBOLP (CAR CTL-STRING))
(FORMAT-CTL-STRING ARGS (CAR CTL-STRING)))
(T (FORMAT-CTL-LIST ARGS (CAR CTL-STRING))))))))
(AND FORMAT-STRING
(SETQ FORMAT-STRING (MAKNAM (NREVERSE (CDR STREAM)))))
(RETURN FORMAT-STRING)))
(DEFUN FORMAT-CTL-LIST (ARGS CTL-LIST)
(FORMAT-CTL-OP (CAR CTL-LIST) ARGS (CDR CTL-LIST)))
(DEFUN FORMAT-CTL-STRING (ARGS CTL-STRING)
(declare (fixnum ctl-index ctl-length))
(DO ((CTL-INDEX 0) (CH) (TEM) (STR) (SYM)
(CTL-LENGTH (FLATSIZE CTL-STRING)))
((>= CTL-INDEX CTL-LENGTH) ARGS)
(SETQ TEM (COND ((STRING-SEARCH-CHAR |Tilde-ascii-value/||
CTL-STRING
CTL-INDEX))
((AND (= |Tilde-ascii-value/|| 26.)
(STRING-SEARCH-CHAR 126. CTL-STRING CTL-INDEX)))
(CTL-LENGTH)))
(COND ((NEQ TEM CTL-INDEX) ;Put out some literal string
(SETQ STR (NSUBSTRING CTL-STRING CTL-INDEX TEM))
(/|--> STANDARD-OUTPUT 'STRING-OUT STR)
(AND (>= (SETQ CTL-INDEX TEM) CTL-LENGTH)
(RETURN ARGS))))
;; (AR-1 CH CTL-INDEX) is a tilde.
(DO ((ATSIGN-FLAG NIL) ;Modifier
(COLON-FLAG NIL) ;Modifier
(PARAMS (ARRAY NIL T 10.))
(PARAM-LEADER -1)
;PARAMS contains the list of numeric parameters
(PARAM-FLAG NIL) ;If T, a parameter has been started in PARAM
(PARAM)) ;PARAM is the parameter currently
; being constructed
((>= (SETQ CTL-INDEX (1+ CTL-INDEX)) CTL-LENGTH))
(SETQ CH (GETCHARN CTL-STRING (1+ CTL-INDEX)))
(COND ((AND (>= CH 48.) (<= CH 57.)) ; "0, "9
(SETQ PARAM (+ (* (OR PARAM 0) 10.) (- CH 48.)) ; "0
PARAM-FLAG T))
((= CH 64.) ;ASCII @
(SETQ ATSIGN-FLAG T))
((= CH 58.) ;ASCII :
(SETQ COLON-FLAG T))
((OR (= CH 86.) (= CH 118.)) ;ASCII V, v
(AS-1 (POP ARGS) PARAMS
(SETQ PARAM-LEADER (1+ PARAM-LEADER)))
(SETQ PARAM NIL PARAM-FLAG NIL))
((= CH 44.)
;comma, begin another parameter, ASCII ,
(AND PARAM-FLAG (AS-1 PARAM PARAMS (SETQ PARAM-LEADER
(1+ PARAM-LEADER))))
(SETQ PARAM NIL PARAM-FLAG T))
;omitted arguments made manifest by the
;presence of a comma come through as NIL
(T ;Must be a command character
;lower-case to upper
(AND (>= CH 97.) (<= CH 122.) (SETQ CH (- CH 32.)))
(SETQ CTL-INDEX (1+ CTL-INDEX)) ;Advance past command char
(AND PARAM-FLAG (AS-1 PARAM PARAMS (SETQ PARAM-LEADER
(1+ PARAM-LEADER))))
(SETQ PARAM-FLAG NIL PARAM NIL TEM NIL)
;STR gets a string which is the name of the operation to do
;consed in the temporary area, TEM gets another random stri
(SETQ
STR (COND ((= CH 92.) ;ASCII \
(LET ((I (STRING-SEARCH-CHAR
92.
CTL-STRING
(1+ CTL-INDEX))))
(AND (NULL I)
(FERROR NIL '|Unmatched \ in control string.|))
(PROG1 (STRING-UPCASE
(SETQ TEM
(NSUBSTRING CTL-STRING
(1+ CTL-INDEX)
I)))
(SETQ CTL-INDEX I))))
(T (ASCII CH))))
;; SYM gets the symbol corresponding to STR
(COND ((SETQ SYM STR)
(SETQ ARGS (FORMAT-CTL-OP SYM ARGS (G-L-P PARAMS))))
(T (FERROR NIL '|~C is an unknown FORMAT op in /"~A/"|
TEM CTL-STRING)))
(RETURN NIL))))))
;Perform a single formatted output operation on specified args.
;Return the remaining args not used up by the operation.
(DEFUN FORMAT-CTL-OP (OP ARGS PARAMS &AUX TEM)
(COND ((SETQ TEM (GET OP 'FORMAT-CTL-ONE-ARG))
(OR ARGS (FERROR NIL '|Arg required for ~A, but no more args| OP))
(FUNCALL TEM (CAR ARGS) PARAMS)
(CDR ARGS))
((SETQ TEM (GET OP 'FORMAT-CTL-NO-ARG))
(FUNCALL TEM PARAMS)
ARGS)
((SETQ TEM (GET OP 'FORMAT-CTL-MULTI-ARG))
(FUNCALL TEM ARGS PARAMS))
((SETQ TEM (GET OP 'FORMAT-CTL-REPEAT-CHAR))
(FORMAT-CTL-REPEAT-CHAR (OR (CAR PARAMS) 1) TEM)
ARGS)
(T (FERROR NIL '|/"~S/" is not defined as a FORMAT command.| OP)
ARGS)))
;;; OK,OK! So we lose a little on floating point now.
(DEFPROP F FORMAT-CTL-DECIMAL FORMAT-CTL-ONE-ARG)
(DEFPROP D FORMAT-CTL-DECIMAL FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-DECIMAL (ARG PARAMS &AUX (WIDTH (CAR PARAMS)) (PADCHAR (CADR PARAMS)))
(COND ((AND COLON-FLAG (< ARG 4000.) (> ARG 0))
(ROMAN-STEP ARG 0))
(ATSIGN-FLAG (ENGLISH-PRINT ARG))
((LET ((BASE 10.) (*NOPOINT T))
(COND ((NULL PADCHAR) (SETQ PADCHAR 32.))
((NOT (NUMBERP PADCHAR))
(SETQ PADCHAR (GETCHARN PADCHAR 1))))
(AND WIDTH (FORMAT-CTL-JUSTIFY WIDTH (FLATC ARG) PADCHAR))
(/|--> STANDARD-OUTPUT 'PRIN1 ARG)))))
(DEFPROP O FORMAT-CTL-OCTAL FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-OCTAL (ARG PARAMS &AUX (WIDTH (CAR PARAMS)) (PADCHAR (CADR PARAMS)))
(LET ((BASE 8))
(COND ((NULL PADCHAR)
(SETQ PADCHAR 40))
((NOT (NUMBERP PADCHAR))
(SETQ PADCHAR (GETCHARN PADCHAR 1))))
(AND WIDTH (FORMAT-CTL-JUSTIFY WIDTH (FLATC ARG) PADCHAR))
(/|--> STANDARD-OUTPUT 'PRIN1 ARG)))
(DEFPROP A FORMAT-CTL-ASCII FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-ASCII (ARG PARAMS &OPTIONAL PRIN1P)
(LET ((EDGE (CAR PARAMS))
(PERIOD (CADR PARAMS))
(MIN (CADDR PARAMS))
(PADCHAR (CADDDR PARAMS)))
(COND ((NULL PADCHAR)
(SETQ PADCHAR 40))
((NOT (NUMBERP PADCHAR))
(SETQ PADCHAR (GETCHARN PADCHAR 1))))
(COND (PRIN1P (/|--> STANDARD-OUTPUT 'PRIN1 ARG))
(T (/|--> STANDARD-OUTPUT 'STRING-OUT ARG)))
(COND ((NOT (NULL EDGE))
(LET ((WIDTH (COND (PRIN1P (FLATSIZE ARG)) ((FLATC ARG)))))
(COND ((NOT (NULL MIN))
(FORMAT-CTL-REPEAT-CHAR MIN PADCHAR)
(SETQ WIDTH (+ WIDTH MIN))))
(COND (PERIOD
(FORMAT-CTL-REPEAT-CHAR
(- (+ EDGE (* (// (+ (- (MAX EDGE WIDTH) EDGE 1)
PERIOD)
PERIOD)
PERIOD))
WIDTH)
PADCHAR))
(T (FORMAT-CTL-JUSTIFY EDGE WIDTH PADCHAR))))))))
(DEFPROP S FORMAT-CTL-SEXP FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-SEXP (ARG PARAMS)
(FORMAT-CTL-ASCII ARG PARAMS T))
(DEFPROP C FORMAT-CTL-CHARACTER FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-CHARACTER (ARG PARAMS)
NIL)
(DEFPROP P FORMAT-CTL-PLURAL FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-PLURAL (ARG PARAMS)
(OR (= ARG 1)
(/|--> STANDARD-OUTPUT 'TYO 115.)))
(DEFPROP * FORMAT-CTL-IGNORE FORMAT-CTL-MULTI-ARG)
(DEFUN FORMAT-CTL-IGNORE (ARGS PARAMS)
(LET ((COUNT (OR (CAR PARAMS) 1)))
(NTHCDR COUNT ARGS)))
(DEFPROP G FORMAT-CTL-GOTO FORMAT-CTL-MULTI-ARG)
(DEFUN FORMAT-CTL-GOTO (ARG PARAMS)
(LET ((COUNT (OR (CAR PARAMS) 1)))
(NTHCDR COUNT FORMAT-ARGLIST)))
(DEFPROP % FORMAT-CTL-NEWLINES FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-NEWLINES (PARAMS)
(declare (fixnum i))
(LET ((COUNT (OR (CAR PARAMS) 1)))
(DO I 0 (1+ I) (= I COUNT)
(/|--> STANDARD-OUTPUT 'NEWLINE))))
(DEFPROP & FORMAT-CTL-FRESH-LINE FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-FRESH-LINE (PARAMS)
(/|--> STANDARD-OUTPUT ':FRESH-LINE))
(DEFPROP X 32. FORMAT-CTL-REPEAT-CHAR) ;SPACE CHAR
(PUTPROP '/|
(COND ((STATUS FEATURE LISPM) 140.) ;FORM-FEED CHAR
(10.))
'FORMAT-CTL-REPEAT-CHAR)
(DEFPROP ~ 126. FORMAT-CTL-REPEAT-CHAR) ;TILDE CHAR
(AND (STATUS FEATURE SAIL)
(PUTPROP (ASCII 26.) ;TILDE CHAR FOR SAIL
26.
'FORMAT-CTL-REPEAT-CHAR))
(DEFUN FORMAT-CTL-REPEAT-CHAR (COUNT CHAR)
(declare (fixnum i))
(DO I 0 (1+ I) (= I COUNT)
(/|--> STANDARD-OUTPUT 'TYO CHAR)))
;; Several commands have a SIZE long object which they must print
;; in a WIDTH wide field. If WIDTH is specified and is greater than
;; the SIZE of the thing to be printed, this put out the right
;; number of CHARs to fill the field. You can call this before
;; or after printing the thing, to get leading or trailing padding.
(DEFUN FORMAT-CTL-JUSTIFY (WIDTH SIZE &OPTIONAL (CHAR 40))
(AND WIDTH (> WIDTH SIZE) (FORMAT-CTL-REPEAT-CHAR (- WIDTH SIZE) CHAR)))
(DEFPROP Q FORMAT-CTL-APPLY FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-APPLY (ARG PARAMS)
(APPLY ARG PARAMS))
(DEFUN CASE-SCAN (GOAL &OPTIONAL (LIM CTL-LENGTH) (TIMES 1))
(declare (fixnum cnt lim times ctl-index))
(*CATCH 'CASE-SCAN
(DO ((CNT 0 (1+ CNT)))
((>= CNT TIMES) T)
(DO ((CH))
((>= CTL-INDEX LIM)
(*THROW 'CASE-SCAN NIL))
(SETQ CH (GETCHARN CTL-STRING (1+ CTL-INDEX))
CTL-INDEX (1+ CTL-INDEX))
(COND ((= CH 126.)
(SETQ CH (GETCHARN CTL-STRING (1+ CTL-INDEX))
CTL-INDEX (1+ CTL-INDEX))
(COND ((= CH GOAL)
(RETURN T))
((= CH 91.)
(CASE-SCAN 93. LIM)))))))))
(DEFPROP /[ FORMAT-CTL-START-CASE FORMAT-CTL-ONE-ARG)
(DEFUN FORMAT-CTL-START-CASE (NUM PARAMS &AUX (START CTL-INDEX))
(AND COLON-FLAG (SETQ NUM (COND (NUM 1) (T 0))))
(AND (NULL NUM)
(FERROR NIL '|The FORMAT /"[/" command must be given a numeric parameter|))
(COND ((>= NUM 0)
(OR (CASE-SCAN 93.)
(FERROR NIL '|Unbalenced conditional in FORMAT control string|))
(LET ((I CTL-INDEX))
(SETQ CTL-INDEX START)
(CASE-SCAN 59. I NUM)))))
(DEFPROP /] FORMAT-CTL-STOP-CASE FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-STOP-CASE (PARAMS)
NIL)
(DEFPROP /; FORMAT-CTL-DELIMIT-CASE FORMAT-CTL-NO-ARG)
(DEFUN FORMAT-CTL-DELIMIT-CASE (PARAMS)
(CASE-SCAN 93.))
(DECLARE (SPECIAL ENGLISH-SMALL ENGLISH-MEDIUM ENGLISH-LARGE))
(DEFUN MAKE-LIST-ARRAY (LIST)
(LET ((A (ARRAY NIL T (LENGTH LIST))))
(FILLARRAY A LIST)
A))
(SETQ ENGLISH-SMALL (MAKE-LIST-ARRAY '(|one| |two| |three| |four| |five| |six|
|seven| |eight| |nine| |ten| |eleven| |twelve|
|thirteen| |fourteen| |fifteen| |sixteen|
|seventeen| |eighteen| |nineteen|)))
(SETQ ENGLISH-MEDIUM (MAKE-LIST-ARRAY '(|twenty| |thirty| |forty| |fifty| |sixty| |seventy|
|eighty| |ninty|)))
(SETQ ENGLISH-LARGE (MAKE-LIST-ARRAY '(|thousand| |million| |billion| |trillion| |quadrillion|
|quintillion|)))
(DEFUN ENGLISH-PRINT (N &OPTIONAL (STREAM STANDARD-OUTPUT))
(declare (fixnum i n limit))
(COND ((ZEROP N)
(/|--> STREAM 'STRING-OUT '|zero|))
((< N 0)
(/|--> STREAM 'STRING-OUT '|minus|)
(/|--> STREAM 'TYO 32.)
(ENGLISH-PRINT (MINUS N) STREAM))
(T
(DO ((N N)
(P)
(FLAG)
(LIMIT 1000000. ;There is some cleverness here for bignums
(// LIMIT 1000.))
(I 1 (1- I)))
((< I 0)
(COND ((> N 0)
(AND FLAG (/|--> STREAM 'TYO 40))
(ENGLISH-PRINT-THOUSAND N STREAM))))
(COND ((NOT (< N LIMIT))
(SETQ P (// N LIMIT)
N (\ N LIMIT))
(COND (FLAG (/|--> STREAM 'TYO 40))
(T (SETQ FLAG T)))
(ENGLISH-PRINT-THOUSAND P STREAM)
(/|--> STREAM 'TYO 40)
(/|--> STREAM 'STRING-OUT (AR-1 ENGLISH-LARGE I))))))))
(DEFUN ENGLISH-PRINT-THOUSAND (N STREAM)
(declare (fixnum i n limit))
(LET ((N (\ N 100.))
(H (// N 100.)))
(COND ((> H 0)
(/|--> STREAM 'STRING-OUT (AR-1 ENGLISH-SMALL (1- H)))
(/|--> STREAM 'TYO 32.)
(/|--> STREAM 'STRING-OUT '|hundred|)
(AND (> N 0) (/|--> STREAM 'TYO 32.))))
(COND ((= N 0))
((< N 20.)
(/|--> STREAM 'STRING-OUT (AR-1 ENGLISH-SMALL (1- N))))
(T
(/|--> STREAM 'STRING-OUT (AR-1 ENGLISH-MEDIUM (- (// N 10.) 2)))
(COND ((ZEROP (SETQ H (\ N 10.))))
(T
(/|--> STREAM 'TYO 45.) ;ASCII -
(/|--> STREAM
'STRING-OUT
(AR-1 ENGLISH-SMALL (1- H)))))))))
(DEFUN ROMAN-STEP (X N)
(COND ((> X 9.)
(ROMAN-STEP (// X 10.) (1+ N))
(SETQ X (\ X 10.))))
(COND ((AND (= X 9) (NOT ROMAN-OLD))
(ROMAN-CHAR 0 N)
(ROMAN-CHAR 0 (1+ N)))
((= X 5)
(ROMAN-CHAR 1 N))
((AND (= X 4) (NOT ROMAN-OLD))
(ROMAN-CHAR 0 N)
(ROMAN-CHAR 1 N))
(T (COND ((> X 5)
(ROMAN-CHAR 1 N)
(SETQ X (- X 5))))
(DO I 0 (1+ I) (>= I X)
(ROMAN-CHAR 0 N)))))
(DEFUN ROMAN-CHAR (I X)
(/|--> STANDARD-OUTPUT
'TYO
(NTH (+ I X X) '(73. 86. 88. 76. 67. 68. 77.))
; I V X L C D M
))
;;; Kludges to make MacLISP like some of the LISPM functions
(SETQ **STREAM** (GENSYM))
(DEFUN /|--> N
(LET ( (STREAM (ARG 1))
(OPERATION (ARG 2))
(ARGUMENT (AND (> N 2) (ARG 3))) )
(COND ((AND (NOT (ATOM STREAM)) (EQ (CAR STREAM) **STREAM**))
(RPLACD STREAM
(CASEQ OPERATION
(TYO (CONS ARGUMENT (CDR STREAM)))
((PRINC PRIN1 STRING-OUT)
(NRECONC (COND ((EQ OPERATION 'PRIN1)
(MAPCAR '(LAMBDA (X)
(GETCHARN X 1))
(EXPLODE ARGUMENT)))
((EXPLODEN ARGUMENT)))
(CDR STREAM)))
((NEWLINE :FRESH-LINE)
(COND ((AND (EQ OPERATION ':FRESH-LINE)
(CDDR STREAM)
(= (CADR STREAM) 10.)
(= (CADDR STREAM) 13.))
(CDR STREAM))
(`(10. 13. ,@(CDR STREAM))))))))
((CASEQ OPERATION
(TYO (TYO ARGUMENT STREAM))
((PRINC STRING-OUT) (PRINC ARGUMENT STREAM))
(PRIN1 (PRIN1 ARGUMENT STREAM))
(NEWLINE (TERPRI STREAM))
(:FRESH-LINE
(AND (NOT (= 0 (CHARPOS (COND ((NULL STREAM) 'T)
((ATOM STREAM) STREAM)
((NULL (CAR STREAM)) 'T)
((CAR STREAM))))))
(TERPRI STREAM))))))))
(DEFUN FORMAT/:STRING-SEARCH-CHAR (CHAR STR START-POS)
(DECLARE (FIXNUM I START-POS STR-LEN))
(DO ((I START-POS (1+ I))
(STR-LEN (FLATC STR)))
((> I STR-LEN) NIL)
(AND (= CHAR (GETCHARN STR (1+ I))) (RETURN I))))
(DEFUN FORMAT/:NSUBSTRING (STR FROM TO)
(DECLARE (FIXNUM I FROM TO))
(DO ((NEW-STR () (PUSH (GETCHARN STR (1+ I)) NEW-STR))
(I FROM (1+ I)))
((>= I TO) (MAKNAM (NREVERSE NEW-STR)))))
(DEFUN FORMAT/:FERROR NARGS
(LET ((STR (APPLY 'FORMAT `( () ,(arg 2) ,@(cddr (listify nargs))))))
(COND ((NULL (ARG 1)) (ERROR STR))
((ERROR STR () (ARG 1))))))
(DEFUN G-L-P (ARRAY)
(DECLARE (FIXNUM I N))
(DO ((NEW-LIST NIL (CONS (AR-1 ARRAY I) NEW-LIST))
(I 0 (1+ I))
(N (CADR (ARRAYDIMS ARRAY))))
((>= I N) (NREVERSE NEW-LIST))))